SPACE 2/SPACE - Library 2 - Volume 1.iso/apps/25/applic/rgen.pas

Pascal/Delphi Source File | 1986-06-19 | 5.3 KB | 270 lines

(*
    RLEGEN, Translate DEGAS .PI1 file into a .RLE file

    FUNCTION:

    RLEGEN takes a DEGAS low resolution (.PI1) file and encodes it
    in the CompuServe .RLE format.

    USAGE:

    When you run this program you will be prompted for the names
    of two files, the input .PI1 file and the output .RLE file.
    Conversion will then take place.

    NOTES:

    RLE Format files are 256 wide by 192 deep, with each pixel
    being either black or white.  DEGAS .PI1 files are 320 wide
    by 200 deep, with each pixel having 4 bits of color information.

    As you might guess, there is quite a bit of information lost when
    encoding a .PI1 into a .RLE file; 64 columns, 8 rows, and 3 bits
    of color depth.  Pretty grim.

    This program will encode a subset of the entire DEGAS image
    occupying the upper left hand corner of the image.  All pixels
    which are not black are considered full white.  This conversion
    works poorly for images which are shaded.  A better version
    of this program will come in the future...

    AUTHOR:

    Charles McGuinness, May 1986

    MODIFICATIONS:

    <your name goes here ... don't forget to describe what you did>

*)

program rlegen;

type    t_image = array [0..15999] of integer;
    t_outf = packed file of byte;

var    image            : ^t_image;

    inf            : file of integer;
    outf            : t_outf;

    map            : array [0..15] of boolean;

    d_type            : integer;

    x,y,i,j,k        : integer;

    black,white,state    : integer;

    line            : string;

procedure io_check(b:boolean); external;
function io_result:integer; external;

procedure my_halt;
begin
    write('Press RETURN to continue: ');
    readln;
    halt;
end;

(*
    get_pix, Get the value of a pixel in the DEGAS image

    This routine will return TRUE if the specified pixel is WHITE,
    FALSE if the pixel is BLACK.  Does full magic to map colors
    through the color map.

*)

function get_pix(x,y:integer):boolean;
var    offset,    bit, normal, color : integer;
begin


    offset    := y * 80 + (x div 16)*4;

    bit    := shr($8000,x & 15);    (* The Bit mask            *)
    normal    := 15 - (x & 15);    (* # shifts to normalize    *)

    color    := shl(shr(image^[offset+0] & bit,normal),0) |
           shl(shr(image^[offset+1] & bit,normal),1) |
           shl(shr(image^[offset+2] & bit,normal),2) |
           shl(shr(image^[offset+3] & bit,normal),3);

    get_pix := map[color];
end;

(*    putc, for us C programmers who have a hard time changing to pascal *)
procedure putc(c:integer;var f:t_outf);
begin
    f^ := c;
    put(f);
end;

BEGIN        (* MAIN *)

writeln('DEGAS to RLE Conversion utility, version 1.0 (May 28, 1986)');
writeln;
writeln('Copyright (C) 1986, Charles McGuinness');
writeln;
writeln('Portions if this product are Copyright (c) 1986, OSS and CCD.');
writeln('Used by Permission of OSS.');
writeln;
writeln;

    new(image);

    write('Input (.PI1) filename:  ');
    readln(line);
    io_check(FALSE);
    reset(inf,line);
    if (io_result <> 0) then begin
        writeln('Unable to open ',line);
        my_halt;
        end;

    io_check(TRUE);
    write('Output (.RLE) filename: ');
    readln(line);
    io_check(FALSE);
    rewrite(outf,line);
    if (io_result <> 0) then begin
        writeln('Unabe to create ',line);
        my_halt;
        end;

    io_check(TRUE);

    writeln;

(*    1: Read in file type                        *)

    d_type := inf^;        get(inf);

    if (d_type <> 0) then begin
        write('File is not DEGAS low resolution.  Press return:');
        close(inf);
        close(outf);
        halt;
        end;

(*    2: Read color map                        *)

    for i:= 0 to 15 do begin
        d_type    := inf^;
        get(inf);
        map[i] := (d_type & $777) <> 0;
        end;


(*    3: Read in image                        *)

    writeln('Reading DEGAS image in....');
    writeln;
    write('<    0>');
    for i:=0 to 15999 do begin
        image^[i] := inf^;
        get(inf);
        if ((i mod 80) = 39) then
            write('.');
        if ((i mod (80*64)) = (80*64)-1) then begin
            writeln;
            write('<',((i+1) div 80):5,'>');
            end;
        end;

    writeln; writeln;

    close(inf);


    writeln('Generating .RLE file ...');
    writeln;
    write('<    0>');
    putc(27,outf);
    putc(ord('G'),outf);
    putc(ord('H'),outf);

(*    4: Convert!                            *)

    white    := 0;
    black    := 0;
    state    := 1;

    for y := 0 to 191 do begin

    write('.');
    if ((y mod 64) = 63) then begin
        writeln;
        write('<',(y+1):5,'>')
        end;

    for x := 0 to 255 do

    case (state) of

    0:                 (* White            *)

        if (get_pix(x,y)) then begin    (* Still white...    *)
            white := succ(white);
            if (white = 94) then begin
                putc(white+32,outf);
                putc(32,outf);
                white := 0;
                end;
            end
        else begin
            putc(white+32,outf);
            black := 1;
            white := 0;
            state := 1;
            end;


    1:                (* Black            *)

        if (not get_pix(x,y)) then begin
                    (*    Still black        *)
            black := succ(black);
            if (black = 94) then begin
                putc(black+32,outf);
                putc(32,outf);
                black := 0;
                end;
            end
        else begin
            putc(black+32,outf);
            white := 1;
            black := 0;
            state := 0;
            end;
        end (* case *);

    end; (* for y *)

    case (state) of

    0:    begin                (* White        *)
        putc(white+32,outf);
        putc(32,outf);
        end;

    1:                    (* Black        *)
        putc(black+32,outf);
    end;



    putc(27,outf);                (* Escape        *)
    putc(ord('G'),outf);
    putc(ord('N'),outf);

    close(outf);

    writeln;
    writeln;
    writeln('DEGAS to RLE conversion finished.');
    my_halt;
end.
əəəəəəəəəəəəəəəəəəəəəəəə